home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / amib.stklos < prev    next >
Encoding:
Text File  |  1996-07-05  |  20.2 KB  |  599 lines
  1. #!/bin/sh
  2. :; exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;;
  4. ;;;; a m i b . s t k l o s  --  A mini interface builder. I hope it will serve 
  5. ;;;;                    as the basis of something more complete...
  6. ;;;;
  7. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  8. ;;;; 
  9. ;;;; Permission to use, copy, and/or distribute this software and its
  10. ;;;; documentation for any purpose and without fee is hereby granted, provided
  11. ;;;; that both the above copyright notice and this permission notice appear in
  12. ;;;; all copies and derived works.  Fees for distribution or use of this
  13. ;;;; software or derived works may only be charged with express written
  14. ;;;; permission of the copyright holder.  
  15. ;;;; This software is provided ``as is'' without express or implied warranty.
  16. ;;;;
  17. ;;;;
  18. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  19. ;;;;    Creation date: 22-May-1995 14:56
  20. ;;;; Last file update:  5-Jul-1996 15:27
  21.  
  22. (require "Tk-classes")
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;;;
  26. ;;;; Definitions.
  27. ;;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. (define *amib-version*         0.3)
  30. (define *pretty-names*        (make-hash-table))
  31. (define *current-file*        #f)
  32. (define *special-slots*        '("id" "eid" "parent"))
  33. (define *delay*            100)
  34. ;;;;
  35. ;;;; All the widgets and their defaults
  36. ;;;;
  37. (define *table-defaults*
  38.   `(("Button"        ,<Button>
  39.             (:text "Button"))
  40.     ("Canvas"        ,<Canvas>
  41.             (:width 200 :height 100 :border-width 3 :relief "raised"))
  42.     ("Check button"    ,<Check-button>    
  43.             (:text "Check" :anchor "w"))
  44.     ("Frame"        ,<Frame>
  45.             (:width 50 :height 50 :relief "ridge" :border-width 2))
  46.     ("Label"        ,<Label>
  47.             (:text "Label"))
  48.     ("Labeled entry"    ,<Labeled-entry>
  49.             (:title "Title"))
  50.     ("Listbox"        ,<Listbox>
  51.                 (:relief raised))
  52.     ("Message"        ,<Message>
  53.             (:text "Message" :relief "raised" :aspect 1000))
  54.     ("Radio button"    ,<Radio-button>    
  55.             (:text "Radio" :anchor "w"))
  56.     ("Scale"        ,<Scale>
  57.             ())    ))
  58.  
  59. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60. ;;;;
  61. ;;;; Drag and Drop stuff
  62. ;;;;
  63. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64. (define d-n-d-widget   #f)    ; The widget whih we can drag and drop
  65. (define d-n-d-defaults #f)    ; Its defaults
  66.  
  67. ;; Default bindings
  68. (bind "Dnd" "<ButtonRelease-1>" (lambda (|X| |Y| x y)
  69.                   (Drag-n-Drop-Finish |X| |Y|)
  70.                   'break))
  71.  
  72. (define (make-drag-n-drop-widget type initargs)
  73.   (let ((m (make <Menu> :border-width 12 :background "Blue")))
  74.     (pack (apply make type :parent m initargs) :padx 2 :pady 2)
  75.     m))
  76.  
  77. (define (Drag-n-Drop-Motion)
  78.   (when d-n-d-widget
  79.       (apply menu-post d-n-d-widget (winfo 'pointerxy d-n-d-widget))
  80.       (after *delay* (lambda () (Drag-n-Drop-Motion)))))
  81.  
  82. (define (Drag-n-Drop-Finish X Y)
  83.   (when d-n-d-widget
  84.     (let ((dwidth  (winfo 'width d-n-d-widget))
  85.       (dheight (winfo 'height d-n-d-widget)))
  86.       ;; Unpost the d-n-d-widget to see on which window we depose it
  87.       (menu-unpost d-n-d-widget)
  88.       
  89.       (let* ((p    (Id->instance (winfo 'containing X Y)))
  90.          (top  (Id->instance (winfo 'toplevel p))))
  91.     (when (string=? (slot-ref top 'class) "Amib-toplevel")
  92.       ;; OK. We try to depose the new widget in a valid toplevel
  93.       (let* ((w    (apply make (car d-n-d-defaults) :parent p 
  94.                   (cadr d-n-d-defaults)))
  95.          (pw   (max 1 (winfo 'width  p)))
  96.          (ph   (max 1 (winfo 'height p)))
  97.          (x    (- X (winfo 'x top) (winfo 'x p)))
  98.          (y    (- Y (winfo 'y top) (winfo 'y p)))
  99.          (relw (/ dwidth pw))
  100.          (relh (/ dheight ph)))
  101.         (place w :relx (/ x pw) :rely (/ y ph) :relwidth relw :relheight relh)
  102.         (raise w)
  103.  
  104.         ;; Associate bindings for manipulating the new widget
  105.         (bind w "<Shift-1>"     (lambda (|X| |Y|)
  106.                       (widget-resize-start w |X| |Y|)
  107.                       'break))
  108.         (bind w "<Button-2>"    (lambda () (edit-widget w) 'break))
  109.         (bind w "<Shift-3>"        (lambda () (edit-widget w) 'break)) ; for Win32
  110.         (bind w "<Button-3>"    (lambda () (destroy w) 'break))))))
  111.  
  112.     ;; We can now delete the drag and drop window,which doesn't serve anymore
  113.     (destroy d-n-d-widget)
  114.     (set! d-n-d-widget #f)))
  115.  
  116.  
  117.  
  118. (define (create-new-widget lb x y Xabs Yabs)
  119.   (unless d-n-d-widget
  120.       (let* ((index  (nearest lb y))
  121.          (type   (list-ref (value lb) index))
  122.          (search (assoc type *table-defaults*)))
  123.     (when search 
  124.         ;; Create a drag and drow window and post it under the mouse
  125.         (let ((W (apply make-drag-n-drop-widget (cadr search) (cddr search))))
  126.           (menu-post W Xabs Yabs)
  127.           (bindtags W (cons "Dnd" (bindtags W)))
  128.           (set! d-n-d-widget   W)
  129.           (set! d-n-d-defaults (cdr search))
  130.           (after *delay* (lambda () (Drag-n-Drop-Motion))))))))
  131.  
  132. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  133. ;;;;
  134. ;;;; Define a Toplevel for working
  135. ;;;;
  136. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  137. (define new-amib-toplevel
  138.   (let ((count 0))
  139.     (lambda ()
  140.       (let* ((n (* count 20))
  141.          (t (make <Toplevel> :title (format #f "Toplevel # ~A" count)
  142.               :class "Amib-toplevel"
  143.               :geometry (format #f "450x300+~A+~A" n n))))
  144.     (set! count (+ count 1))
  145.     (pack  (make <Frame> :parent t) :expand #t :fill "both")))))
  146.  
  147. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  148. ;;;;
  149. ;;;; build-interface        -- construct the button panel
  150. ;;;;
  151. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  152.  
  153. (define (build-interface)
  154.   (let* ((mess   (make <Label> :relief "ridge" :border-width 3 :foreground "blue"
  155.                    :text (format #f "A Mini Interface Builder (V~A)" 
  156.                          *amib-version*)))
  157.      ;; Menus
  158.      (menus  `((" File "
  159.               ("Load"     ,load-file)
  160.               ("Save"     ,save-file)
  161.               ("Save as" ,write-file)
  162.               ("")
  163.               ("Quit"     ,quit))
  164.            (" Toplevel "
  165.               ("Create"    ,new-amib-toplevel))
  166.            ((" Help " :side "right" :fill "x")
  167.               ("About"    ,(lambda () (stk:make-help "amib-abt.html")))
  168.               ("Help"   ,(lambda () (stk:make-help "amib-hlp.html"))))))
  169.      ;; Menu bar
  170.      (bar     (make-menubar *top-root* menus))
  171.      ;; Widget Panel
  172.      (chooser (make <Scroll-Listbox> :value (map car *table-defaults*)))
  173.      (lb      (listbox-of chooser)))
  174.  
  175.     ;; Associate new bindings to the listbox
  176.     (bind lb "<ButtonRelease-1>"  (lambda (x y |X| |Y|)
  177.                     (create-new-widget lb x y |X| |Y|)))
  178.  
  179.     ;; Change characteristics of root window
  180.     (set! (title *top-root*)          (format #f "AMIB ~A" *amib-version*))
  181.     (set! (maximum-size *top-root*) '(1000 1000))
  182.     (set! (geometry *top-root*)        "+10-10")
  183.  
  184.     ;; Pack everybody
  185.     (pack mess :fill "x" :ipadx 30 :ipady 5 :padx 5 :pady 5)
  186.     (pack bar  :fill "x" :ipadx 30)
  187.     (pack chooser :expand #t :fill 'both :ipadx 5 :ipady 5 :padx 5 :pady 5)))
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190. ;;;;
  191. ;;;; Widget resize
  192. ;;;;
  193. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  194.  
  195. (define *cursors* #("top_left_corner"    "top_side"    "top_right_corner"
  196.             "left_side"          "crosshair"   "right_side"
  197.             "bottom_left_corner" "bottom_side" "bottom_right_corner"))
  198.  
  199. (define *positions* #(NW N NE W center E SW S SE))
  200.  
  201. (define *grips-on* #f)
  202. (define *resizing* #f)
  203. (define *vector-of-grips* (make-vector 9 #f))
  204.  
  205. (define (widget-resize-start W X Y)
  206.   (let ((parent (parent W))
  207.     (width  (winfo 'width  W))
  208.     (height (winfo 'height W))
  209.     (bw     (if (slot-exists? W 'border-width) (border-width W) 0)))
  210.     (if (equal? *grips-on* W)
  211.     (begin
  212.       (widget-resize-clear)
  213.       (set! *grips-on* #f))
  214.     (begin
  215.       (widget-resize-clear)
  216.       (set! *grips-on* W)
  217.       (dotimes (i 9)
  218.          (let ((butt (make <Frame> :parent parent :width 8 :height 8
  219.                    :background "blue" :border-width 2 :relief "raised" 
  220.                    :cursor (vector-ref *cursors* i))))
  221.            (place butt :in W :bordermode "outside" 
  222.               :anchor (vector-ref *positions* (- 8 i))
  223.               :relx (* 0.5 (modulo i 3))
  224.               :rely (* 0.5 (quotient i 3)))
  225.  
  226.            ;; Associate bindings to this grip
  227.            (bind butt "<ButtonPress-1>"
  228.              (lambda ()
  229.                (set! *resizing* #t)
  230.                (widget-resize-motion W (vector-ref *positions* i))
  231.                'break))
  232.            (bind butt "<ButtonRelease-1>" 
  233.              (lambda ()
  234.                (set! *resizing* #f)
  235.                (widget-resize-release W)
  236.                'break))
  237.  
  238.            ;; Keep the grip in the global vector
  239.            (vector-set! *vector-of-grips* i butt)))
  240.  
  241.       ;; Place the central button on top (its index is 4)
  242.       (raise W)
  243.       (raise (vector-ref *vector-of-grips* 4))))))
  244.  
  245. (define (widget-resize-clear)
  246.   (for-each (lambda (x) (if (Tk-widget? x) (destroy x)))
  247.         (vector->list *vector-of-grips*)))
  248.  
  249. (define (widget-resize-motion W index)
  250.   (when *resizing*
  251.     (let* ((parent (parent W))
  252.        (pos-x  (winfo 'rootx parent))
  253.        (pos-y  (winfo 'rooty parent))
  254.        (width  (winfo 'width W))
  255.        (height (winfo 'height W))
  256.        (x      (winfo 'pointerx W))
  257.        (y      (winfo 'pointery W))
  258.        (x1     (- (winfo 'rootx W) pos-x))
  259.        (y1       (- (winfo 'rooty W) pos-y))
  260.        (x2     (+ x1 width))
  261.        (y2       (+ y1 height))
  262.        (x      (- X pos-x))
  263.        (y       (- Y pos-y)))
  264.       (case index
  265.      ((NW)        (set! x1 x)    (set! y1 y))
  266.      ((N)             (set! y1 y))
  267.      ((NE)     (set! x2 x)    (set! y1 y))
  268.      ((W)       (set! x1 x))
  269.          ((E)        (set! x2 x))
  270.          ((SW)        (set! x1 x)    (set! y2 y))
  271.          ((S)             (set! y2 y))
  272.      ((SE)        (set! x2 x)    (set! y2 y))
  273.      ((center) (set! x1 (- x (quotient width 2)))
  274.                (set! y1 (- y (quotient height 2)))
  275.            (set! x2 (+ x1 width))        
  276.            (set! y2 (+ y1 height))))
  277.       (place 'forget W)
  278.       (place W :in parent :x x1 :y y1 :width (- x2 x1) :height (- y2 y1))
  279.  
  280.       (after 30 (lambda () (widget-resize-motion W index))))))
  281.       
  282. (define (widget-resize-release W)
  283.   ;; Calculate the relative width and height of the widget 
  284.   (let* ((parent (parent W))
  285.      (pw     (winfo 'width  parent))
  286.      (ph     (winfo 'height parent))
  287.      (pos-x  (winfo 'rootx parent))
  288.      (pos-y  (winfo 'rooty parent))
  289.      (width  (winfo 'width W))
  290.      (height (winfo 'height W))
  291.      (x      (- (winfo 'rootx W) pos-x))
  292.      (y     (- (winfo 'rooty W) pos-y)))
  293.     (place 'forget W)
  294.     (place W :in parent 
  295.          :relx      (if (= pw 0) 0 (/ x pw))
  296.          :rely      (if (= ph 0) 0 (/ y ph))
  297.          :relwidth  (if (= pw 0) 0 (/ width pw))
  298.          :relheight (if (= ph 0) 0 (/ height ph)))))
  299.  
  300. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  301. ;;;;
  302. ;;;; Widget Geometry management
  303. ;;;;
  304. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  305.  
  306. (define (MAKE-PACKING-WINDOW W)
  307.   (define old-packing-options (if (equal? (winfo 'manager W) "pack")
  308.                   (pack 'info W)
  309.                   '()))
  310.   (define (build-var-name x)
  311.     (string->symbol (format #f "amib-~A~A" x (widget-name (Id W)))))
  312.   
  313.   (define (make-var v val)
  314.     (let ((var (build-var-name v)))
  315.       (eval `(define ,var ',val) (global-environment))
  316.       var))
  317.  
  318.   (define (change-pack-opt)
  319.     (pack 'forget W)
  320.     (pack W :side    (eval (build-var-name 'side))
  321.         :anchor  (eval (build-var-name 'anchor))
  322.         :fill    (eval (build-var-name 'fill))
  323.         :expand  (eval (build-var-name 'expand))
  324.         :padx    (eval (build-var-name 'padx))
  325.         :pady    (eval (build-var-name 'pady))
  326.         :ipadx   (eval (build-var-name 'ipadx))
  327.         :ipady   (eval (build-var-name 'ipady))))
  328.  
  329.   (define (make-side parent)
  330.     (let* ((f   (make <Frame> :parent parent :relief "groove" :border-width 2))
  331.        (val (get-keyword :side old-packing-options "top"))
  332.        (v   (make-var 'side val)))
  333.       (pack (make <Label> :text "Side: " :parent f :font "fixed") :side "left")
  334.       (for-each (lambda (x)
  335.           (pack (make <Radio-button> :parent f :text x :variable v
  336.                                :value x :command change-pack-opt)
  337.             :side "left" :expand #t :fill "x"))
  338.         '("top" "bottom" "left" "right"))
  339.       f))
  340.  
  341.   (define (make-anchor parent)
  342.     (let* ((f   (make <Frame> :parent parent :relief "groove" :border-width 2))
  343.        (val (string->symbol (get-keyword :anchor old-packing-options "center")))
  344.        (v   (make-var 'anchor val)))
  345.       (dotimes (i 3)
  346.     (let ((g (make <Frame> :parent f)))
  347.       (dotimes (j 3)
  348.         (let ((anchor (vector-ref *positions* (+ (* i 3) j))))
  349.           (pack (make <Radio-Button> :text anchor :width 10 :parent g
  350.                        :variable v :value anchor :anchor "w"
  351.                      :command change-pack-opt)
  352.             :side "left" :expand #t :fill "x")))
  353.       (pack g :side "top")))
  354.       f))
  355.   
  356.   (define (make-fill parent)
  357.     (let* ((f   (make <Frame> :parent parent :relief "groove" :border-width 2))
  358.        (val (get-keyword :fill old-packing-options "none"))
  359.        (v   (make-var 'fill val)))
  360.       (pack (make <Label> :text "Fill: " :parent f :font "fixed") :side "left")
  361.       (for-each (lambda (x)
  362.           (pack (make <Radio-button> :parent f :text x :variable v
  363.                   :value x :command  change-pack-opt)
  364.             :side "left" :expand #t :fill "x"))
  365.           '("none" "x" "y" "both"))
  366.       f))
  367.  
  368.   (define (make-expand parent)
  369.     (let ((val (get-keyword :expand old-packing-options #f)))
  370.       (make <Check-button> :parent parent :relief "groove" :border-width 2
  371.         :text "Expand" :variable (make-var 'expand val) :value val
  372.         :command change-pack-opt)))
  373.   
  374.   (define (make-padding parent)
  375.     (let ((f (make <Frame> :parent parent :relief "groove" :border-width 2)))
  376.       (for-each (lambda (x)
  377.           (let* ((val (get-keyword (make-keyword x) old-packing-options 10))
  378.              (v   (make-var x val)))
  379.             (pack (make <Scale> :orientation "h" :parent f :text x
  380.                 :variable v :value val 
  381.                 :command (lambda (_) (change-pack-opt)))
  382.               :expand #t :fill "x")))
  383.         '(ipadx ipady padx pady))
  384.       f))
  385.  
  386.   ;; MAKE-PACKING-WINDOW starts here
  387.   (let ((top     (make <Toplevel> :title "Packer options" :class "Amib" 
  388.                          :geometry "-100+100")))
  389.     (pack (make-side   top)
  390.       (make-anchor top)
  391.       (make-fill top) 
  392.       (make-expand top)
  393.       (make-padding top)
  394.       :padx 5 :pady 5 :fill "x")
  395.     (pack (make <Button> :parent top :text "Dismiss" :command (lambda () 
  396.                                 (destroy top)))
  397.       :fill "x")))
  398.  
  399. (define (use-pack-for-widget W)
  400.   (place 'forget W)
  401.   (pack W :in (parent W))
  402.   (update)
  403.   (make-packing-window W))
  404.  
  405. (define (use-place-for-widget W)
  406.     (pack 'forget W)
  407.     (place W :in (parent W))
  408.     (update))       
  409.  
  410. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  411. ;;;;
  412. ;;;; edit-widget        -- Interactively change widget options
  413. ;;;;
  414. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
  415. (define (edit-widget w)
  416.   (letrec ((top    (make <Toplevel> :class "Amib" :title "Widget Editor"
  417.                      :geometry "-10+10"))
  418.        (slots  (map (lambda (x) (symbol->string (if (pair? x) (car x) x)))
  419.             (class-slots (class-of w))))
  420.        (filter (lambda (slots forget)
  421.              (let loop ((l slots) (res '()))
  422.                (cond 
  423.             ((null? l)     res)
  424.             ((member (car l) forget)
  425.                      (loop (cdr l) res))
  426.             (else        (loop (cdr l) (cons (car l) res)))))))
  427.        (maxl  0))
  428.     
  429.     ;; Display only useful slots
  430.     (set! slots (sort (filter slots *special-slots*) string<?))
  431.     (set! maxl (apply max (map string-length slots)))
  432.     
  433.     ;; Pretty name of this object
  434.     (let ((name-editor (make <Labeled-Entry> 
  435.                  :parent top 
  436.                  :title "Widget name"
  437.                  :value (hash-table-get *pretty-names* w "?none?"))))
  438.       (bind (entry-of name-editor) "<Return>"
  439.         (lambda ()
  440.           (hash-table-put! *pretty-names* w (value name-editor))))
  441.       (pack name-editor :expand #t :fill 'x))
  442.  
  443.     ;; Display the geometry manager used for this widget
  444.     (let* ((f  (make <Frame> :border-width 2 :relief "ridge" :parent top))
  445.        (v  (string->symbol (format #f "cb-var~A" (widget-name (Id w)))))
  446.        (c1 (make <Radio-Button> :text "Packed" :variable v :parent f
  447.              :value "pack" 
  448.              :command (lambda () (Use-pack-for-widget w))))
  449.        (c2 (make <Radio-Button> :text "Placed" :variable v :parent f
  450.              :value "place"
  451.              :command (lambda () (Use-place-for-widget w)))))
  452.       ;; Set the valid check button
  453.       (eval `(set! ,v ,(if (null? (place 'info w)) "pack" "place")))
  454.       (pack c1 c2 :side "left" :expand #t :fill "x")
  455.       (pack f :expand #t :fill "x"))
  456.  
  457.     ;; Display the widget editor
  458.     (for-each (lambda (s)
  459.         (let* ((name (string->symbol s))
  460.                (le   (make <Labeled-Entry> :parent top :title name
  461.                    :width 40
  462.                    :value (slot-ref w (string->symbol s)))))
  463.           ;; Customize label
  464.           (set! (width  (label-of le))  maxl)
  465.           (set! (anchor (label-of le)) "e")
  466.           ;; Customize entry
  467.           (bind (entry-of le) "<Return>" (lambda ()
  468.                            (slot-set! w name (value le))))
  469.           ;; Pack the new entry
  470.           (pack le :fill "y" :expand #t)))
  471.           slots)
  472.     ;; Dismiss button
  473.     (pack (make <Button> :text "Dismiss" :parent top
  474.              :command (lambda () (destroy top)))
  475.       :expand #t 
  476.       :fill 'x)))
  477.  
  478. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  479. ;;;;
  480. ;;;; Code generation
  481. ;;;;
  482. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  483.  
  484. (define (Pretty-name w)
  485.   (let ((name (hash-table-get *pretty-names* w #f)))
  486.     (unless name
  487.        ;; If this object has no name, a name is generated for it
  488.        (set! name (if (eqv? w *root*) "*root*" (gensym "W")))
  489.        (hash-table-put! *pretty-names* w name))
  490.     name))
  491.  
  492. ;;;;
  493. ;;;; Generate-placement: generate pack or place depending of the geometry manager
  494. ;;;; used.
  495. ;;;;
  496. (define-method generate-placement ((w <Tk-widget>))
  497.   (let* ((infos      (place 'info w))
  498.      (use-pack?  (null? infos)))
  499.     (if use-pack?
  500.     (set! infos (pack 'info w)))
  501.  
  502.     (format #t "(~A ~A " (if use-pack? "pack " "place") (pretty-name w))
  503.  
  504.     ;; Display informations returned by Tk
  505.     (let loop ((i infos))
  506.       (cond 
  507.          ((null? i)        (display ")\n\n"))
  508.      ((eqv? (car i) ':in)    (format #t "\n       :in ~A" 
  509.                     (pretty-name 
  510.                         (Id->instance (eval (cadr i)))))
  511.                 (loop (cddr i)))
  512.      (ELSE            (let ((val (cadr i)))
  513.                   (format #t "\n       ~S " (car i))
  514.                   (if (number? val)
  515.                       (display val)
  516.                       (format #t "\"~A\"" val)))
  517.                 (loop (cddr i)))))))
  518.  
  519. (define-method generate-placement ((w <Toplevel>))
  520.   (format #f ";; End of Toplevel ~A\n\n" (pretty-name w)))
  521.  
  522. ;;;;
  523. ;;;; Generate-code-for-widget methods
  524. ;;;;
  525. (define-method generate-code-for-widget ((w <Toplevel>))
  526.   (format #t "\n;; Start of Toplevel ~A\n" (pretty-name w))
  527.   (next-method))
  528.  
  529. (define-method generate-code-for-widget ((w <Tk-widget>))
  530.   ;; Generate name
  531.   (format #t ";-----------\n(define ~A (make ~A\n\t:parent ~A\n" 
  532.          (pretty-name w) (class-name (class-of w)) (pretty-name (parent w)))
  533.  
  534.   ;; Generate non special slots
  535.   (for-each (lambda (slot)
  536.           (unless (member slot *special-slots*)
  537.             (unless (member (symbol->string (car slot)) *special-slots*)
  538.                ;; Generate code for this slot (which is for sure a list)
  539.                (let* ((slot-name (car slot))
  540.                   (val       (slot-ref w slot-name))
  541.                   (init-key  (get-keyword :init-keyword (cdr slot) #f)))
  542.               (when (and init-key (not (equal? (slot-ref w slot-name) "")))
  543.              (format #t "\t~S ~A~S\n"
  544.                 init-key (if (list? val) "'" "") val))))))
  545.         (class-slots (class-of w)))
  546.   ;; Close parenthesis
  547.   (format #t "))\n\n")
  548.   
  549.   ;; Generate code for embedded widgets. Don't do this if w is a composite
  550.   (unless (is-a? w <Tk-composite-widget>)
  551.      (for-each generate-code-for-widget
  552.            (map Id->instance (winfo 'children w))))
  553.   
  554.   ;; Generate placement for this widget
  555.   (generate-placement w))
  556.  
  557. ;;;;
  558. ;;;; Generate-code (the entry point of code generation)
  559. ;;;;
  560. (define (generate-code file)
  561.   (with-output-to-file file
  562.     (lambda ()
  563.       (format #t ";;\n;; Code generated by Amib (v~A)\n;;\n" *amib-version*)
  564.       (for-each (lambda (x)
  565.           (when (and (is-a? x <Toplevel>) 
  566.                  (not (equal? (slot-ref x 'class) "Amib")))
  567.             (generate-code-for-widget x)))
  568.         (map Id->instance (winfo 'children *root*))))))
  569.  
  570. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  571. ;;;;
  572. ;;;; File Management
  573. ;;;;
  574. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  575.  
  576. (define (save-file)
  577.   (if *current-file*
  578.       (generate-code *current-file*)
  579.       (write-file)))
  580.  
  581. (define (load-file)
  582.   (let ((f (make-file-box)))
  583.     (when f (load f))))
  584.  
  585. (define (write-file)
  586.   (let ((f (make-file-box)))
  587.     (when f
  588.       (set! *current-file* f)
  589.       (generate-code f))))
  590.       
  591. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  592. ;;;;
  593. ;;;; Inits
  594. ;;;;
  595. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  596. (bind "all" "<ButtonRelease-1>" (lambda () (set! *resizing* #f)))
  597. (new-amib-toplevel)
  598. (build-interface)
  599.